home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Hardcore Visual Basic 5.0 (2nd Edition)
/
Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso
/
Code
/
picglass.cls
< prev
next >
Wrap
Text File
|
1997-06-14
|
9KB
|
259 lines
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "CPictureGlass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Public Enum EErrorPictureGlass
eeBasePictureGlass = 13140 ' CPictureGlass
eePictureNotBitmap ' Picture must contain bitmap
eeInvalidCanvas ' Drawing surface lacks required properties
End Enum
Private cvsDst As Object, hdcDst As Long, clrMask As Long
Private hdcImage As Long, hbmpImage As Long, hbmpImageOld As Long
Private hdcMask As Long, hbmpMask As Long, hbmpMaskOld As Long
Private hdcBack As Long, hbmpBack As Long, hbmpBackOld As Long
Private hdcCache As Long, hbmpCache As Long, hbmpCacheOld As Long
Private fExist As Boolean, fVisible As Boolean
Private xOld As Long, yOld As Long
Private dxSrc As Long, dySrc As Long
Private xLeft As Long, yTop As Long
Sub Create(cvsDstA As Object, picSrc As Picture, clrMaskA As Long, _
Optional x As Variant, Optional y As Variant)
' Clean up any old instance before creating a new one
If fExist Then Destroy
' Save at module level for use in properties and methods
clrMask = clrMaskA
Set cvsDst = cvsDstA
If picSrc.Type <> vbPicTypeBitmap Then ErrRaise eePictureNotBitmap
' Catch any errors from canvas that doesn't have needed properties
On Error GoTo CreateErrorCanvas
With cvsDst
hdcDst = .hDC
' Get size and position of image in pixels
dxSrc = .ScaleX(picSrc.Width, vbHimetric, vbPixels)
dySrc = .ScaleY(picSrc.Height, vbHimetric, vbPixels)
' Default is the center
If IsMissing(x) Then x = .ScaleWidth / 2
If IsMissing(y) Then y = .ScaleHeight / 2
xLeft = .ScaleX(x, .ScaleMode, vbPixels)
yTop = .ScaleY(y, .ScaleMode, vbPixels)
End With
Dim cPlanes As Long, cPixelBits As Long
cPlanes = GetDeviceCaps(hdcDst, PLANES)
cPixelBits = GetDeviceCaps(hdcDst, BITSPIXEL)
' Create memory DC compatible with screen for picture copy
Dim hdcSrc As Long, hdcSrcOld As Long, hbmpSrcOld As Long
hdcSrc = CreateCompatibleDC(0&)
' Select bitmap into DC
hbmpSrcOld = SelectObject(hdcSrc, picSrc.Handle)
' Create memory DC for image with inverted background (AND mask)
hdcImage = CreateCompatibleDC(0&)
' Create color bitmap same as screen
hbmpImage = CreateBitmap(dxSrc, dySrc, cPlanes, cPixelBits, 0&)
hbmpImageOld = SelectObject(hdcImage, hbmpImage)
' Make copy of picture because we don't want to modify original
Call BitBlt(hdcImage, 0, 0, dxSrc, dySrc, hdcSrc, 0, 0, vbSrcCopy)
' Create DC for monochrome mask of image (XOR mask)
hdcMask = CreateCompatibleDC(0&)
' Create bitmap (monochrome by default)
hbmpMask = CreateCompatibleBitmap(hdcMask, dxSrc, dySrc)
' Select it into DC
hbmpMaskOld = SelectObject(hdcMask, hbmpMask)
' Set background of source to the mask color
Call SetBkColor(hdcSrc, clrMask)
' Copy color bitmap to monochrome DC to create mono mask
Call BitBlt(hdcMask, 0, 0, dxSrc, dySrc, hdcSrc, 0, 0, vbSrcCopy)
' We've copied and used the source picture, so give it back
Call SelectObject(hdcSrc, hbmpSrcOld)
Call DeleteDC(hdcSrc)
' Invert background of image to create AND Mask
Call SetBkColor(hdcImage, vbBlack)
Call SetTextColor(hdcImage, vbWhite)
Call BitBlt(hdcImage, 0, 0, dxSrc, dySrc, hdcMask, 0, 0, vbSrcAnd)
' Create memory DCs for old background and cache
hdcBack = CreateCompatibleDC(0&)
hbmpBack = CreateBitmap(dxSrc, dySrc, cPlanes, cPixelBits, 0&)
hbmpBackOld = SelectObject(hdcBack, hbmpBack)
hdcCache = CreateCompatibleDC(0&)
hbmpCache = CreateBitmap(dxSrc, dySrc, cPlanes, cPixelBits, 0&)
hbmpCacheOld = SelectObject(hdcCache, hbmpCache)
' Invalid x and y indicate first move hasn't occurred
xOld = -1: yOld = -1
fExist = True: fVisible = True
Exit Sub
CreateErrorCanvas:
ErrRaise eeInvalidCanvas
End Sub
Private Sub Class_Terminate()
Destroy
End Sub
Sub Destroy()
BugAssert fExist
' Select old mask back to DC
Call SelectObject(hdcMask, hbmpMaskOld)
' Now it's safe to delete DC and bitmask
Call DeleteDC(hdcMask)
Call DeleteObject(hbmpMask)
' Clean up inverted image DC
Call SelectObject(hdcImage, hbmpImageOld)
Call DeleteDC(hdcImage)
Call DeleteObject(hbmpImage)
' Clean up cache DC
Call SelectObject(hdcCache, hbmpCacheOld)
Call DeleteDC(hdcCache)
Call DeleteObject(hbmpCache)
' Clean up old background DC
Call SelectObject(hdcBack, hbmpBackOld)
Call DeleteDC(hdcBack)
Call DeleteObject(hbmpBack)
xOld = -1: yOld = -1
fExist = False
End Sub
Public Sub Draw()
With cvsDst
BugAssert fExist
If fVisible = False Then Exit Sub
' Copy old background to its last location
If xOld <> -1 Then
Call BitBlt(hdcDst, xOld, yOld, dxSrc, dySrc, _
hdcBack, 0, 0, vbSrcCopy)
End If
' Save current background and position for next time
Call BitBlt(hdcBack, 0, 0, dxSrc, dySrc, _
hdcDst, xLeft, yTop, vbSrcCopy)
' Create cache copy of background to work on
Call BitBlt(hdcCache, 0, 0, dxSrc, dySrc, _
hdcDst, xLeft, yTop, vbSrcCopy)
xOld = xLeft: yOld = yTop
' Save color and set to white and black
Dim clrBack As Long, clrFore As Long
clrBack = GetBkColor(hdcCache)
clrFore = GetTextColor(hdcCache)
Call SetBkColor(hdcCache, vbWhite)
Call SetTextColor(hdcCache, vbBlack)
' Mask the background
Call BitBlt(hdcCache, 0, 0, dxSrc, dySrc, hdcMask, 0, 0, vbSrcAnd)
' Put image in hole created by mask
Call BitBlt(hdcCache, 0, 0, dxSrc, dySrc, hdcImage, 0, 0, vbSrcPaint)
' Restore color
Call SetBkColor(hdcCache, clrBack)
Call SetTextColor(hdcCache, clrFore)
' Put finished cache on screen
Call BitBlt(hdcDst, xLeft, yTop, dxSrc, dySrc, _
hdcCache, 0, 0, vbSrcCopy)
End With
End Sub
Public Sub Remove()
BugAssert fExist
If fVisible = False Then Exit Sub
' Copy the old background to its last location
If xOld <> -1 Then
Call BitBlt(hdcDst, xOld, yOld, dxSrc, dySrc, _
hdcBack, 0, 0, vbSrcCopy)
End If
End Sub
Public Sub Move(xLeftA As Long, Optional yTopA As Long = -1)
With cvsDst
BugAssert fExist
xLeft = .ScaleX(xLeftA, .ScaleMode, vbPixels)
If yTopA <> -1 Then yTop = .ScaleY(yTopA, .ScaleMode, vbPixels)
Draw
End With
End Sub
Property Get MaskColor() As Long
BugAssert fExist
MaskColor = clrMask
End Property
Property Get Left() As Single
BugAssert fExist
Left = cvsDst.ScaleX(xLeft, vbPixels, cvsDst.ScaleMode)
End Property
Property Let Left(rLeft As Single)
BugAssert fExist
xLeft = cvsDst.ScaleX(rLeft, cvsDst.ScaleMode, vbPixels)
Draw
End Property
Property Get Top() As Single
BugAssert fExist
Top = cvsDst.ScaleY(yTop, vbPixels, cvsDst.ScaleMode)
End Property
Property Let Top(rTop As Single)
BugAssert fExist
yTop = cvsDst.ScaleY(rTop, cvsDst.ScaleMode, vbPixels)
Draw
End Property
Property Get Width() As Single
BugAssert fExist
Width = cvsDst.ScaleX(dxSrc, vbPixels, cvsDst.ScaleMode)
End Property
Property Get Height() As Single
BugAssert fExist
Height = cvsDst.ScaleY(dySrc, vbPixels, cvsDst.ScaleMode)
End Property
Property Get Visible() As Boolean
BugAssert fExist
Visible = fVisible
End Property
Property Let Visible(fVisibleA As Boolean)
BugAssert fExist
fVisible = fVisibleA
End Property
'
#If fComponent = 0 Then
Private Sub ErrRaise(e As Long)
Dim sText As String, sSource As String
If e > 1000 Then
sSource = App.ExeName & ".PictureGlass"
Select Case e
Case eeBasePictureGlass
BugAssert True
Case eePictureNotBitmap
sText = "Picture must contain bitmap"
Case eeInvalidCanvas
sText = "Drawing surface lacks required properties"
End Select
Err.Raise COMError(e), sSource, sText
Else
' Raise standard Visual Basic error
sSource = App.ExeName & ".VBError"
Err.Raise e, sSource
End If
End Sub
#End If